home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / examples / defsystem.lisp < prev    next >
Lisp/Scheme  |  1990-09-19  |  7KB  |  202 lines
  1. ;;; -*- Mode:Lisp; Package:USER; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                   P.O. BOX 149149                                |
  8. ;;;                              AUSTIN, TEXAS 78714-9149                            |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21.  
  22. (in-package "USER")
  23.  
  24. #-kcl
  25. (progn
  26. #+explorer
  27. (defsystem clio-examples
  28.   (:name "CLIO Example Programs")
  29.   (:short-name "CLIO Examples")
  30.   (:pathname-default "CLIO:EXAMPLES;")
  31.   
  32.   (:initial-status :experimental)
  33.  
  34.   ;;  The real source files...
  35.   (:module package          ("package"))
  36.   (:module clio-extras      ("cmd-frame"))
  37.   (:module example-contacts ("sketchpad"))
  38.   (:module sketch           ("sketch"))
  39.  
  40.   ;;  The transformations...
  41.   (:compile-load package)
  42.   (:compile-load clio-extras)
  43.   (:compile-load example-contacts
  44.          (:fasload  package)
  45.          (:fasload  package))
  46.   
  47.   (:compile-load sketch
  48.          (:fasload  package clio-extras example-contacts)
  49.          (:fasload  package clio-extras example-contacts)))
  50.  
  51.  
  52.  
  53.  
  54.  
  55.  
  56. (defun load-clio-examples (&key (host "CLIO") (directory "EXAMPLES") (compile-p t) (verbose-p t))
  57.   (dolist (file (mapcar
  58.           #'(lambda (name)
  59.               (make-pathname
  60.             :host      host
  61.             :directory directory
  62.             :name      name
  63.             :version   :newest))
  64.           '("PACKAGE"
  65.             "CMD-FRAME"
  66.             "SKETCHPAD"
  67.             "SKETCH")))
  68.     (when compile-p
  69.       (when verbose-p
  70.     (format t "~% Compiling ~12t~a..." file))
  71.       (compile-file file))
  72.     
  73.     (when verbose-p
  74.       (format t "~% Loading ~12t~a..." file))
  75.     (load file)
  76.     
  77.     (when (and compile-p verbose-p)
  78.       (format t "~%"))))
  79. )
  80.  
  81. #+kcl
  82. (progn
  83.  
  84. (defvar *clio-examples-root-directory* "/src/dec/dec-kcl/clue/clio/examples")
  85.  
  86. (defvar *clio-examples-source-pathname*
  87.     (pathname (format nil "~A/*.l" *clio-examples-root-directory*)))
  88.  
  89. (defvar *clio-examples-binary-pathname*
  90.     (pathname (format nil "~A/*.o" *clio-examples-root-directory*)))
  91.  
  92. (defvar *clio-examples-file-table* (make-hash-table :test 'equal))
  93.  
  94. (defun compile-clio-examples (&optional
  95.                   (source-pathname-defaults *clio-examples-source-pathname*)
  96.                   (binary-pathname-defaults *clio-examples-binary-pathname*)
  97.                   &key
  98.                   (force-p nil))
  99.  
  100.   ;; The pathname-defaults above might only be strings, so coerce them
  101.   ;; to pathnames.  Build a default binary path with every component
  102.   ;; of the source except the file type.  This should prevent
  103.   ;; (compile-clio-examples "*.lisp") from destroying source files.
  104.   (let* ((source-path (pathname source-pathname-defaults))
  105.      (path        (make-pathname
  106.                :host      (pathname-host      source-path)
  107.                :device    (pathname-device    source-path)
  108.                :directory (pathname-directory source-path)
  109.                :name      (pathname-name      source-path)
  110.                :type      nil
  111.                :version   (pathname-version   source-path)))
  112.      (binary-path (merge-pathnames binary-pathname-defaults
  113.                        path)))
  114.                        
  115.     ;; Make sure source-path and binary-path file types are distinct so
  116.     ;; we don't accidently overwrite the source files.  NIL should be an
  117.     ;; ok type, but anything else spells trouble.
  118.     (if (and (equal (pathname-type source-path)
  119.             (pathname-type binary-path))
  120.          (not (null (pathname-type binary-path))))
  121.     (error "Source and binary pathname defaults have same type ~s ~s"
  122.            source-path binary-path))
  123.  
  124.     (format t ";;; Default paths: ~s ~s~%" source-path binary-path)
  125.  
  126.     (let ((newest-source-fwd 0))
  127.       (labels ((compile-lisp (filename &optional (binary-filename filename))
  128.          (let ((source (merge-pathnames filename source-path))
  129.                (binary (merge-pathnames binary-filename binary-path)))
  130.            (when (or force-p
  131.                  (not (probe-file source)) ; maybe no type in pathname
  132.                  (not (probe-file binary))
  133.                  (< (file-write-date binary)
  134.                 (setq newest-source-fwd
  135.                       (max newest-source-fwd
  136.                        (file-write-date source)))))
  137.              ;; If the source and binary pathnames are the same,
  138.              ;; then don't supply an output file just to be sure
  139.              ;; compile-file defaults correctly.
  140.              #+(or kcl ibcl) (load source)
  141.              (if (equal source binary)
  142.              (compile-file source)
  143.              (compile-file source :output-file binary)))
  144.            binary))
  145.            (load-binary (filename)
  146.          (let* ((binary (merge-pathnames filename binary-path))
  147.             (fwd (and (probe-file binary) (file-write-date binary))))
  148.            (unless (and fwd
  149.                 (let ((lfwd (gethash filename *clio-examples-file-table*)))
  150.                   (eql fwd lfwd)))
  151.              (load binary))
  152.            (setf (gethash filename *clio-examples-file-table*) fwd)))
  153.            (compile-and-load (filename &optional (binary-filename filename))
  154.          (compile-lisp filename binary-filename)
  155.          (load-binary binary-filename))
  156.            (module (filename) (compile-and-load filename)))
  157.  
  158.     ;; Now compile and load all the files.
  159.     (module "package")
  160.     (module "cmd-frame")
  161.     (module "sketchpad")
  162.     (module "sketch")
  163.     (module "precom")))))
  164.  
  165. (defun load-clio-examples (&optional
  166.                (binary-pathname-defaults *clio-examples-binary-pathname*))
  167.  
  168.   ;; The pathname-defaults above might only be strings, so coerce them
  169.   ;; to pathnames.  Build a default binary path with every component
  170.   ;; of the source except the file type.  
  171.   (let* ((source-path (pathname ""))
  172.      (path        (make-pathname
  173.                :host      (pathname-host      source-path)
  174.                :device    (pathname-device    source-path)
  175.                :directory (pathname-directory source-path)
  176.                :name      (pathname-name      source-path)
  177.                :type      nil
  178.                :version   (pathname-version   source-path)))
  179.      (binary-path (merge-pathnames binary-pathname-defaults
  180.                        path)))
  181.  
  182.     (labels ((load-binary (filename)
  183.            (let* ((binary (merge-pathnames filename binary-path))
  184.               (fwd (and (probe-file binary) (file-write-date binary))))
  185.          (unless (and fwd
  186.                   (let ((lfwd (gethash filename *clio-examples-file-table*)))
  187.                 (eql fwd lfwd)))
  188.            (load binary))
  189.          (setf (gethash filename *clio-examples-file-table*) fwd)))
  190.          (module (filename) (load-binary filename)))
  191.  
  192.       ;; Now load all the files.
  193.       (module "package")
  194.       (module "cmd-frame")
  195.       (module "sketchpad")
  196.       (module "sketch")
  197.       (module "precom"))))
  198.  
  199.  
  200. )
  201.  
  202.